home *** CD-ROM | disk | FTP | other *** search
/ C/C++ Users Group Library 1996 July / C-C++ Users Group Library July 1996.iso / vol_100 / 176_01 / xlmath.c < prev    next >
Text File  |  1985-12-19  |  11KB  |  527 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. #include <fmath.h>
  10. overlay "math"
  11. #else
  12. #include <math.h>
  13. #endif
  14.  
  15. /* external variables */
  16. extern NODE *true;
  17.  
  18. /* forward declarations */
  19. FORWARD NODE *unary();
  20. FORWARD NODE *binary();
  21. FORWARD NODE *predicate();
  22. FORWARD NODE *compare();
  23.  
  24. /* xadd - builtin function for addition */
  25. NODE *xadd(args)
  26.   NODE *args;
  27. {
  28.     return (binary(args,'+'));
  29. }
  30.  
  31. /* xsub - builtin function for subtraction */
  32. NODE *xsub(args)
  33.   NODE *args;
  34. {
  35.     return (binary(args,'-'));
  36. }
  37.  
  38. /* xmul - builtin function for multiplication */
  39. NODE *xmul(args)
  40.   NODE *args;
  41. {
  42.     return (binary(args,'*'));
  43. }
  44.  
  45. /* xdiv - builtin function for division */
  46. NODE *xdiv(args)
  47.   NODE *args;
  48. {
  49.     return (binary(args,'/'));
  50. }
  51.  
  52. /* xrem - builtin function for remainder */
  53. NODE *xrem(args)
  54.   NODE *args;
  55. {
  56.     return (binary(args,'%'));
  57. }
  58.  
  59. /* xmin - builtin function for minimum */
  60. NODE *xmin(args)
  61.   NODE *args;
  62. {
  63.     return (binary(args,'m'));
  64. }
  65.  
  66. /* xmax - builtin function for maximum */
  67. NODE *xmax(args)
  68.   NODE *args;
  69. {
  70.     return (binary(args,'M'));
  71. }
  72.  
  73. /* xexpt - built-in function 'expt' */
  74. NODE *xexpt(args)
  75.   NODE *args;
  76. {
  77.     return (binary(args,'E'));
  78. }
  79.  
  80. /* xbitand - builtin function for bitwise and */
  81. NODE *xbitand(args)
  82.   NODE *args;
  83. {
  84.     return (binary(args,'&'));
  85. }
  86.  
  87. /* xbitior - builtin function for bitwise inclusive or */
  88. NODE *xbitior(args)
  89.   NODE *args;
  90. {
  91.     return (binary(args,'|'));
  92. }
  93.  
  94. /* xbitxor - builtin function for bitwise exclusive or */
  95. NODE *xbitxor(args)
  96.   NODE *args;
  97. {
  98.     return (binary(args,'^'));
  99. }
  100.  
  101. /* binary - handle binary operations */
  102. LOCAL NODE *binary(args,fcn)
  103.   NODE *args; int fcn;
  104. {
  105.     FIXNUM ival,iarg;
  106.     FLONUM fval,farg;
  107.     NODE *arg;
  108.     int imode;
  109.  
  110.     /* get the first argument */
  111.     arg = xlarg(&args);
  112.  
  113.     /* set the type of the first argument */
  114.     if (fixp(arg)) {
  115.     ival = getfixnum(arg);
  116.     imode = TRUE;
  117.     }
  118.     else if (floatp(arg)) {
  119.     fval = getflonum(arg);
  120.     imode = FALSE;
  121.     }
  122.     else
  123.     xlerror("bad argument type",arg);
  124.  
  125.     /* treat '-' with a single argument as a special case */
  126.     if (fcn == '-' && args == NIL)
  127.     if (imode)
  128.         ival = -ival;
  129.     else
  130.         fval = -fval;
  131.  
  132.     /* handle each remaining argument */
  133.     while (args) {
  134.  
  135.     /* get the next argument */
  136.     arg = xlarg(&args);
  137.  
  138.     /* check its type */
  139.     if (fixp(arg))
  140.         if (imode) iarg = getfixnum(arg);
  141.         else farg = (FLONUM)getfixnum(arg);
  142.     else if (floatp(arg))
  143.         if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
  144.         else farg = getflonum(arg);
  145.     else
  146.         xlerror("bad argument type",arg);
  147.  
  148.     /* accumulate the result value */
  149.     if (imode)
  150.         switch (fcn) {
  151.         case '+':    ival += iarg; break;
  152.         case '-':    ival -= iarg; break;
  153.         case '*':    ival *= iarg; break;
  154.         case '/':    checkizero(iarg); ival /= iarg; break;
  155.         case '%':    checkizero(iarg); ival %= iarg; break;
  156.         case 'M':    if (iarg > ival) ival = iarg; break;
  157.         case 'm':    if (iarg < ival) ival = iarg; break;
  158.         case '&':    ival &= iarg; break;
  159.         case '|':    ival |= iarg; break;
  160.         case '^':    ival ^= iarg; break;
  161.         default:    badiop();
  162.         }
  163.     else
  164.         switch (fcn) {
  165.         case '+':    fval += farg; break;
  166.         case '-':    fval -= farg; break;
  167.         case '*':    fval *= farg; break;
  168.         case '/':    checkfzero(farg); fval /= farg; break;
  169.         case 'M':    if (farg > fval) fval = farg; break;
  170.         case 'm':    if (farg < fval) fval = farg; break;
  171.         case 'E':    fval = pow(fval,farg); break;
  172.         default:    badfop();
  173.         }
  174.     }
  175.  
  176.     /* return the result */
  177.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  178. }
  179.  
  180. /* checkizero - check for integer division by zero */
  181. checkizero(iarg)
  182.   FIXNUM iarg;
  183. {
  184.     if (iarg == 0)
  185.     xlfail("division by zero");
  186. }
  187.  
  188. /* checkfzero - check for floating point division by zero */
  189. checkfzero(farg)
  190.   FLONUM farg;
  191. {
  192.     if (farg == 0.0)
  193.     xlfail("division by zero");
  194. }
  195.  
  196. /* checkfneg - check for square root of a negative number */
  197. checkfneg(farg)
  198.   FLONUM farg;
  199. {
  200.     if (farg < 0.0)
  201.     xlfail("square root of a negative number");
  202. }
  203.  
  204. /* xbitnot - bitwise not */
  205. NODE *xbitnot(args)
  206.   NODE *args;
  207. {
  208.     return (unary(args,'~'));
  209. }
  210.  
  211. /* xabs - builtin function for absolute value */
  212. NODE *xabs(args)
  213.   NODE *args;
  214. {
  215.     return (unary(args,'A'));
  216. }
  217.  
  218. /* xadd1 - builtin function for adding one */
  219. NODE *xadd1(args)
  220.   NODE *args;
  221. {
  222.     return (unary(args,'+'));
  223. }
  224.  
  225. /* xsub1 - builtin function for subtracting one */
  226. NODE *xsub1(args)
  227.   NODE *args;
  228. {
  229.     return (unary(args,'-'));
  230. }
  231.  
  232. /* xsin - built-in function 'sin' */
  233. NODE *xsin(args)
  234.   NODE *args;
  235. {
  236.     return (unary(args,'S'));
  237. }
  238.  
  239. /* xcos - built-in function 'cos' */
  240. NODE *xcos(args)
  241.   NODE *args;
  242. {
  243.     return (unary(args,'C'));
  244. }
  245.  
  246. /* xtan - built-in function 'tan' */
  247. NODE *xtan(args)
  248.   NODE *args;
  249. {
  250.     return (unary(args,'T'));
  251. }
  252.  
  253. /* xexp - built-in function 'exp' */
  254. NODE *xexp(args)
  255.   NODE *args;
  256. {
  257.     return (unary(args,'E'));
  258. }
  259.  
  260. /* xsqrt - built-in function 'sqrt' */
  261. NODE *xsqrt(args)
  262.   NODE *args;
  263. {
  264.     return (unary(args,'R'));
  265. }
  266.  
  267. /* xfix - built-in function 'fix' */
  268. NODE *xfix(args)
  269.   NODE *args;
  270. {
  271.     return (unary(args,'I'));
  272. }
  273.  
  274. /* xfloat - built-in function 'float' */
  275. NODE *xfloat(args)
  276.   NODE *args;
  277. {
  278.     return (unary(args,'F'));
  279. }
  280.  
  281. /* xrand - built-in function 'random' */
  282. NODE *xrand(args)
  283.   NODE *args;
  284. {
  285.     return (unary(args,'R'));
  286. }
  287.  
  288. /* unary - handle unary operations */
  289. LOCAL NODE *unary(args,fcn)
  290.   NODE *args; int fcn;
  291. {
  292.     FLONUM fval;
  293.     FIXNUM ival;
  294.     NODE *arg;
  295.  
  296.     /* get the argument */
  297.     arg = xlarg(&args);
  298.     xllastarg(args);
  299.  
  300.     /* check its type */
  301.     if (fixp(arg)) {
  302.     ival = getfixnum(arg);
  303.     switch (fcn) {
  304.     case '~':    ival = ~ival; break;
  305.     case 'A':    ival = abs(ival); break;
  306.     case '+':    ival++; break;
  307.     case '-':    ival--; break;
  308.     case 'I':    break;
  309.     case 'F':    return (cvflonum((FLONUM)ival));
  310.     case 'R':    ival = (FIXNUM)osrand((int)ival); break;
  311.     default:    badiop();
  312.     }
  313.     return (cvfixnum(ival));
  314.     }
  315.     else if (floatp(arg)) {
  316.     fval = getflonum(arg);
  317.     switch (fcn) {
  318.     case 'A':    fval = fabs(fval); break;
  319.     case '+':    fval += 1.0; break;
  320.     case '-':    fval -= 1.0; break;
  321.     case 'S':    fval = sin(fval); break;
  322.     case 'C':    fval = cos(fval); break;
  323.     case 'T':    fval = tan(fval); break;
  324.     case 'E':    fval = exp(fval); break;
  325.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  326.     case 'I':    return (cvfixnum((FIXNUM)fval));
  327.     case 'F':    break;
  328.     default:    badfop();
  329.     }
  330.     return (cvflonum(fval));
  331.     }
  332.     else
  333.     xlerror("bad argument type",arg);
  334. }
  335.  
  336. /* xminusp - is this number negative? */
  337. NODE *xminusp(args)
  338.   NODE *args;
  339. {
  340.     return (predicate(args,'-'));
  341. }
  342.  
  343. /* xzerop - is this number zero? */
  344. NODE *xzerop(args)
  345.   NODE *args;
  346. {
  347.     return (predicate(args,'Z'));
  348. }
  349.  
  350. /* xplusp - is this number positive? */
  351. NODE *xplusp(args)
  352.   NODE *args;
  353. {
  354.     return (predicate(args,'+'));
  355. }
  356.  
  357. /* xevenp - is this number even? */
  358. NODE *xevenp(args)
  359.   NODE *args;
  360. {
  361.     return (predicate(args,'E'));
  362. }
  363.  
  364. /* xoddp - is this number odd? */
  365. NODE *xoddp(args)
  366.   NODE *args;
  367. {
  368.     return (predicate(args,'O'));
  369. }
  370.  
  371. /* predicate - handle a predicate function */
  372. LOCAL NODE *predicate(args,fcn)
  373.   NODE *args; int fcn;
  374. {
  375.     FLONUM fval;
  376.     FIXNUM ival;
  377.     NODE *arg;
  378.  
  379.     /* get the argument */
  380.     arg = xlarg(&args);
  381.     xllastarg(args);
  382.  
  383.     /* check the argument type */
  384.     if (fixp(arg)) {
  385.     ival = getfixnum(arg);
  386.     switch (fcn) {
  387.     case '-':    ival = (ival < 0); break;
  388.     case 'Z':    ival = (ival == 0); break;
  389.     case '+':    ival = (ival > 0); break;
  390.     case 'E':    ival = ((ival & 1) == 0); break;
  391.     case 'O':    ival = ((ival & 1) != 0); break;
  392.     default:    badiop();
  393.     }
  394.     }
  395.     else if (floatp(arg)) {
  396.     fval = getflonum(arg);
  397.     switch (fcn) {
  398.     case '-':    ival = (fval < 0); break;
  399.     case 'Z':    ival = (fval =